home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / INVOKE.R < prev    next >
Encoding:
Text File  |  1992-02-10  |  8.5 KB  |  355 lines
  1. /*
  2.  * invoke.r - contains invoke, apply
  3.  */
  4.  
  5. #if COMPILER
  6.  
  7. /*
  8.  * invoke - perform general invocation on a value.
  9.  */
  10. int invoke(nargs, args, rslt, succ_cont)
  11. int nargs;
  12. dptr args;
  13. dptr rslt;
  14. continuation succ_cont;
  15.    {
  16.    tended struct descrip callee;
  17.    struct b_proc *proc;
  18.    C_integer n;
  19.  
  20.    /*
  21.     * remove the operation being called from the argument list.
  22.     */
  23.    deref(&args[0], &callee);
  24.    ++args;
  25.    nargs -= 1;
  26.  
  27.    if (is:procedure(callee))
  28.       return (*((struct b_proc *)BlkLoc(callee))->ccode)(nargs, args, rslt,
  29.          succ_cont);
  30.    else if (cnv:C_integer(callee, n)) {
  31.       if (n <= 0)
  32.          n += nargs + 1;
  33.       if (n <= 0 || n > nargs)
  34.          return A_Resume;
  35.       *rslt = args[n - 1];
  36.       return A_Continue;
  37.       }
  38.    else if (cnv:string(callee, callee)) {
  39.       proc = strprc(&callee, (C_integer)nargs);
  40.       if (proc == NULL)
  41.          RunErr(106, &callee);
  42.       return (*(proc)->ccode)(nargs, args, rslt, succ_cont);
  43.       }
  44.    else 
  45.       RunErr(106, &callee);
  46.    }
  47.  
  48.  
  49. /*
  50.  * apply - implement binary bang. Construct an argument list for
  51.  *   invoke() from the callee and the list it is applied to.
  52.  */
  53. int apply(callee, lst, rslt, succ_cont)
  54. dptr callee;
  55. dptr lst;
  56. dptr rslt;
  57. continuation succ_cont;
  58.    {
  59.    tended struct descrip dlst;
  60.    struct tend_desc *tnd_args;  /* place to tend arguments to invoke() */
  61.    union block *ep;
  62.    int nargs;
  63.    word i, j;
  64.    word indx;
  65.    int signal;
  66.  
  67.    deref(lst, &dlst);
  68.  
  69.    if (!is:list(dlst))
  70.       RunErr(108, &dlst);
  71.  
  72.    /*
  73.     * Copy the arguments from the list into an tended array of descriptors.
  74.     */
  75.    nargs = BlkLoc(dlst)->list.size + 1;
  76.    tnd_args = (struct tend_desc *)malloc((msize)(sizeof(struct tend_desc)
  77.       + (nargs - 1) * sizeof(struct descrip)));
  78.    if (tnd_args == NULL)
  79.       RunErr(305, NULL);
  80.  
  81.    tnd_args->d[0] = *callee;
  82.    indx = 1;
  83.    for (ep = BlkLoc(dlst)->list.listhead; ep != NULL; ep = ep->lelem.listnext) {
  84.       for (i = 0; i < ep->lelem.nused; i++) {
  85.          j = ep->lelem.first + i;
  86.          if (j >= ep->lelem.nslots)
  87.             j -= ep->lelem.nslots;
  88.          tnd_args->d[indx++] = ep->lelem.lslots[j];
  89.          }
  90.       }
  91.    tnd_args->num = nargs;
  92.    tnd_args->previous = tend;
  93.    tend = tnd_args;
  94.  
  95.    signal = invoke(indx, tnd_args->d, rslt, succ_cont);
  96.  
  97.    tend = tnd_args->previous;
  98.    free(tnd_args);
  99.    return signal;
  100.    }
  101.  
  102. #else                    /* COMPILER */
  103.  
  104. #ifdef EventMon
  105. #include "../h/opdefs.h"
  106. #endif                    /* EventMon */
  107.  
  108. #ifdef TraceBack
  109. extern dptr xargp;
  110. extern word xnargs;
  111. #endif                     /* TraceBack */
  112.  
  113.  
  114. /*
  115.  * invoke -- Perform setup for invocation.  
  116.  */
  117. invoke(nargs,cargp,n)
  118. dptr *cargp;
  119. int nargs, *n;
  120. {
  121.    register struct pf_marker *newpfp;
  122.    register dptr newargp;
  123.    register word *newsp = sp;
  124.    tended struct descrip arg_sv;
  125.  
  126. #ifdef SCO_XENIX
  127.    register dptr p;
  128. #endif                    /* SCO_XENIX */
  129.  
  130.    register word i;
  131.    struct b_proc *proc;
  132.    int nparam;
  133.    char strbuf[MaxCvtLen];
  134.  
  135.    /*
  136.     * Point newargp at Arg0 and dereference it.
  137.     */
  138.    newargp = (dptr )(sp - 1) - nargs;
  139.  
  140. #ifdef TraceBack
  141.    xnargs = nargs;
  142.    xargp = newargp;
  143. #endif                    /* TraceBack */
  144.  
  145.    Deref(newargp[0]);
  146.    
  147.    /*
  148.     * See what course the invocation is to take.
  149.     */
  150.    if (newargp->dword != D_Proc) {
  151.       C_integer tmp;
  152.       /*
  153.        * Arg0 is not a procedure.
  154.        */
  155.  
  156.       if (cnv:C_integer(newargp[0], tmp)) {
  157.          MakeInt(tmp,&newargp[0]);
  158.  
  159.          /*
  160.       * Arg0 is an integer, select result.
  161.       */
  162.          i = cvpos(IntVal(newargp[0]), (word)nargs);
  163.          if (i == CvtFail || i > nargs)
  164.             return I_Fail;
  165.  
  166. #ifdef SCO_XENIX
  167.          p = newargp + i;
  168.          newargp[0] = *p;
  169. #else                    /* SCO_XENIX */
  170.          newargp[0] = newargp[i];
  171. #endif                    /* SCO_XENIX */
  172.  
  173.          sp = (word *)newargp + 1;
  174.          return I_Continue;
  175.          }
  176.       else {
  177.          struct b_proc *tmp;
  178.          /*
  179.       * See if Arg0 can be converted to a string that names a procedure
  180.       *  or operator.  If not, generate run-time error 106.
  181.       */
  182.      if (!cnv:tmp_string(newargp[0],newargp[0]) ||
  183.          ((tmp = strprc(newargp, (C_integer)nargs)) == NULL)) {
  184.             err_msg(106, newargp);
  185.             return I_Fail;
  186.             }
  187.      BlkLoc(newargp[0]) = (union block *)tmp;
  188.      newargp[0].dword = D_Proc;
  189.      }
  190.       }
  191.    
  192.    /*
  193.     * newargp[0] is now a descriptor suitable for invocation.  Dereference
  194.     *  the supplied arguments.
  195.     */
  196.  
  197.    proc = (struct b_proc *)BlkLoc(newargp[0]);
  198.    if (proc->nstatic >= 0)    /* if negative, don't reference arguments */
  199.       for (i = 1; i <= nargs; i++)
  200.          Deref(newargp[i]);
  201.       
  202.    /*
  203.     * Adjust the argument list to conform to what the routine being invoked
  204.     *  expects (proc->nparam).  If nparam is less than 0, the number of
  205.     *  arguments is variable. For functions (ndynam = -1) with a
  206.     *  variable number of arguments, nothing need be done.  For Icon procedures
  207.     *  with a variable number of arguments, arguments beyond abs(nparam) are
  208.     *  put in a list which becomes the last argument.  For fix argument
  209.     *  routines, if too many arguments were supplied, adjusting the stack
  210.     *  pointer is all that is necessary. If too few arguments were supplied,
  211.     *  null descriptors are pushed for each missing argument.
  212.     */
  213.  
  214.    proc = (struct b_proc *)BlkLoc(newargp[0]);
  215.    nparam = (int)proc->nparam;
  216.    if (nparam >= 0) {
  217.       if (nargs > nparam)
  218.          newsp -= (nargs - nparam) * 2;
  219.       else if (nargs < nparam) {
  220.          i = nparam - nargs;
  221.          while (i--) {
  222.             *++newsp = D_Null;
  223.             *++newsp = 0;
  224.             }
  225.          }
  226.       nargs = nparam;
  227.  
  228. #ifdef TraceBack
  229.       xnargs = nargs;
  230. #endif                    /* TraceBack */
  231.  
  232.       }
  233.    else {
  234.       if (proc->ndynam >= 0) { /* this is a procedure */
  235.          int lelems;
  236.      dptr llargp;
  237.  
  238.          if (nargs < abs(nparam) - 1) {
  239.             i = abs(nparam) - 1 - nargs;
  240.             while (i--) {
  241.                *++newsp = D_Null;
  242.                *++newsp = 0;
  243.                }
  244.             nargs = abs(nparam) - 1;
  245.             }
  246.  
  247.      lelems = nargs - (abs(nparam) - 1);
  248.          llargp = &newargp[abs(nparam)];
  249.          arg_sv = llargp[-1];
  250.  
  251.      Ollist(lelems, &llargp[-1]);
  252.  
  253.      llargp[0] = llargp[-1];
  254.      llargp[-1] = arg_sv;
  255.          /*
  256.           *  Reload proc pointer in case Ollist triggered a garbage collection.
  257.           */
  258.          proc = (struct b_proc *)BlkLoc(newargp[0]);
  259.      newsp = (word *)llargp + 1;
  260.      nargs = abs(nparam);
  261.      }
  262.       }
  263.  
  264.    if (proc->ndynam < 0) {
  265.       /*
  266.        * A function is being invoked, so nothing else here needs to be done.
  267.        */
  268.  
  269.       if (nargs < abs(nparam) - 1) {
  270.          i = abs(nparam) - 1 - nargs;
  271.          while (i--) {
  272.             *++newsp = D_Null;
  273.             *++newsp = 0;
  274.             }
  275.          nargs = abs(nparam) - 1;
  276.          }
  277.  
  278.       *n = nargs;
  279.       *cargp = newargp;
  280.       sp = newsp;
  281.  
  282.  
  283. #ifdef EventMon
  284.       EVVal((word)Op_Invoke,E_Ecall);
  285. #endif                    /* EventMon */
  286.  
  287.       if ((nparam < 0) || (proc->ndynam == -2))
  288.          return I_Vararg;
  289.       else
  290.          return I_Builtin;
  291.       }
  292.  
  293.    /*
  294.     * Make a stab at catching interpreter stack overflow.  This does
  295.     * nothing for invocation in a co-expression other than &main.
  296.     */
  297.    if (BlkLoc(k_current) == BlkLoc(k_main) &&
  298.       ((char *)sp + PerilDelta) > (char *)stackend) 
  299.          fatalerr(301, NULL);
  300.  
  301.    /*
  302.     * Build the procedure frame.
  303.     */
  304.    newpfp = (struct pf_marker *)(newsp + 1);
  305.    newpfp->pf_nargs = nargs;
  306.    newpfp->pf_argp = argp;
  307.    newpfp->pf_pfp = pfp;
  308.    newpfp->pf_ilevel = ilevel;
  309.    newpfp->pf_scan = NULL;
  310.  
  311.    newpfp->pf_ipc = ipc;
  312.    newpfp->pf_gfp = gfp;
  313.    newpfp->pf_efp = efp;
  314.  
  315.  
  316.    argp = newargp;
  317.    pfp = newpfp;
  318.    newsp += Vwsizeof(*pfp);
  319.  
  320.    /*
  321.     * If tracing is on, use ctrace to generate a message.
  322.     */   
  323.    if (k_trace) {
  324.       k_trace--;
  325.       ctrace(&(proc->pname), nargs, &newargp[1]);
  326.       }
  327.    
  328.    /*
  329.     * Point ipc at the icode entry point of the procedure being invoked.
  330.     */
  331.    ipc.opnd = (word *)proc->entryp.icode;
  332.  
  333.  
  334.    efp = 0;
  335.    gfp = 0;
  336.  
  337.    /*
  338.     * Push a null descriptor on the stack for each dynamic local.
  339.     */
  340.    for (i = proc->ndynam; i > 0; i--) {
  341.       *++newsp = D_Null;
  342.       *++newsp = 0;
  343.       }
  344.    sp = newsp;
  345.    k_level++;
  346.  
  347. #ifdef EventMon                /* EventMon */
  348.    EVValD(newargp, E_Pcall);
  349. #endif                    /* EventMon */
  350.  
  351.    return I_Continue;
  352. }
  353.  
  354. #endif                    /* COMPILER */
  355.